/* KERNEL.C
 * Copyright (c) 2007 MissingNODE 
 * Based on GPL OpenQM Code
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software Foundation,
 * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 * 
 * 
 * START-HISTORY:
 * Oct-10-2007 Initial Revision
 * END-HISTORY
 *
 * START-DESCRIPTION:
 *
 *
 * END-DESCRIPTION
 *
 * START-CODE
 */

#include <tm.h>
#include <revstamp.h>
#include <header.h>
#include <tio.h>
#include <debug.h>
#include <keys.h>
#include <syscom.h>
#include <config.h>
#include <options.h>
#include <dh_int.h>
#include <locks.h>

#include <setjmp.h>
#include <time.h>
#include <stdarg.h>
#include <signal.h>

#include <sys/wait.h>

bool recover_users(void);
bool IsAdmin(void);

private void init_program(void);
int help(char * key);



void set_date(long int);
void op_sortclr(void);

jmp_buf k_exit;

public bool case_sensitive;



/* Declare opcode functions */

#define _opc_(code, key, name, func, format, stack_use) void func(void);
#include <opcodes.h>
#undef _opc_

/* Build dispatch table */

/* Remap functions that are used in the non-GPL version only to become
   illegal opcodes. Programs compiled on the non-GPL version and moved
   to this version will now report an illegal opcode if they try to use
   these functions.                                                     */

   #define op_trace op_illegal
   #define op_package op_illegal2

#define _opc_(code, key, name, func, format, stack_use) func,
void (*dispatch[])(void) = {
#include <opcodes.h>
};
#undef _opc_

private u_char primary_collation_map[256];   /* For everything except AKs */
private u_char * primary_collation = NULL;   /* Points to above map if active,
                                                else NULL.                   */

private short int assign_user_no(short int user_table_index);
private void kill_process(void);
private void unwind_stack(void);
private void k_release_vars(void);
private void dump_status(void);



   typedef void (*signal_handler)();
   void fatal_signal_handler(int signum);
   void sigusr1_handler(int signum);

/* ======================================================================
   init_kernel()  -  Kernel initialisation                                */

bool init_kernel()
{
 bool status = FALSE;
 short int i;
 USER_ENTRY * uptr;
 unsigned long int m;
 short int msg_no = 1000;   /* User limit reached */

 char * p;

 memset(option_flags, '\0', NumOptions);

 strcpy(national.currency, "$");
 national.thousands = ',';
 national.decimal = '.';

 /* Initialise subsystems. The order is important */

 tzset();

 if (!dio_init()) goto exit_init_kernel;

 c_base = NULL;
 process.call_depth = 0;

 memset((void *)&process, 0, sizeof(struct PROCESS)); /* Set all zero */

 /* Program control */

 init_program();

 process.program.prev = NULL;

 process.debugging = FALSE;

 /* Common areas */

 process.named_common = NULL;
 process.syscom = NULL;

 /* Opcode actions */

 process.break_inhibits = 1;     /* Off until end of LOGIN paragraph */

 if (!tio_init()) goto exit_init_kernel;

 /* Perform licensing checks.
    For a terminal user, we are looking for a user table entry with a zero
    uid field.  For a phantom user, the user table index is in
    phantom_user_index.                                                    */

 StartExclusive(SHORT_CODE, 23);

 if (is_phantom)
  {
   my_uptr = UPtr(phantom_user_index);
  }
 else
  {
   for (i = 1; i <= sysseg->max_users; i++)
    {
     uptr = UPtr(i);
     if (uptr->uid == 0)
      {
       uptr->uid = assign_user_no(i);
       if (uptr->uid == 0)
        {
         msg_no = 1023; /* Port is already in use */
         goto abort_login;
        }
       my_uptr = uptr;
       break;
      }
    }
  }

 if (my_uptr != NULL)
  {
   my_uptr->pid = GetCurrentProcessId();
   strcpy((char *)(my_uptr->ip_addr), ip_addr);
   my_uptr->events = 0;
   my_uptr->flags = 0;
   my_uptr->lockwait_index = 0;
   my_uptr->ttyname[0] = '\0';

   /* Ensure file map table is all zero */

   memset((char *)(my_uptr->file_map), 0, sysseg->num_files * sizeof(unsigned short int));

   if (is_phantom) my_uptr->flags |= USR_PHANTOM;

   if (is_TMVbSrvr) my_uptr->flags |= USR_TMVBSRVR;

   /* Phantom processes have the user name entered by the parent when the
      user table entry is reserved.  For other users, initialise this now. */

   if (!is_phantom)
    {
     m = MAX_USERNAME_LEN + 1;
     if (!GetUserName((char *)(my_uptr->username), &m))
      {
       my_uptr->username[0] = '\0';
      }
     p = ttyname(fileno(stdin));
     if (p != NULL)
      {
       strncpy((char *)(my_uptr->ttyname), p, MAX_TTYNAME_LEN);
       my_uptr->ttyname[MAX_TTYNAME_LEN] = '\0';
      }  
    }
  }

abort_login:
 EndExclusive(SHORT_CODE);

 if (my_uptr == NULL)    /* Failed to login - Message key is in msg_no */
  {
   tio_printf("%s\n", sysmsg(msg_no));
   sleep(2);
   goto exit_init_kernel;
  }

 process.user_no = my_uptr->uid;

 status = TRUE;

exit_init_kernel:
 return status;
}

/* ======================================================================
   Initialise PROGRAM structure on first entry or CALL                    */

private void init_program()
{
 process.program.vars = NULL;
 process.program.col1 = 0;
 process.program.col2 = 0;
 process.program.saved_capture_head = NULL;
 process.program.precision = 4;
 process.program.gosub_depth = 0;
}

/* ======================================================================
   assign_user_no()
   NOTE: The caller must own the SHORT_CODE semaphore.
   Returns the user number, or zero if clash of fixed port/user           */

private short int assign_user_no(short int user_table_index)
{
 short int i;
 short int hi;
 short int portmap_lo_user = 9999;
 short int portmap_hi_user;
 short int portmap_lo_port;
 short int portmap_range;
 short int fixusers_lo_user = 9999;
 short int fixusers_hi_user;

 /* Copy FIXUSERS and PORTMAP related parameters from shared memory
    for best performance                                             */

 if (sysseg->fixusers_range != 0)
  {
   fixusers_lo_user = sysseg->fixusers_base;
   fixusers_hi_user = fixusers_lo_user + sysseg->fixusers_range - 1;

   if ((forced_user_no >= fixusers_lo_user) && (forced_user_no < fixusers_hi_user))
    {
     /* This user is trying to logon as a specific user number */

     if (*(UMap(forced_user_no))) return 0;
     *(UMap(forced_user_no)) = user_table_index;
     return forced_user_no;
    }
  }

 if ((portmap_range = sysseg->portmap_range) != 0)
  {
   portmap_lo_user = sysseg->portmap_base_user;
   portmap_hi_user = portmap_lo_user + portmap_range - 1;
   portmap_lo_port = sysseg->portmap_base_port;

   if ((port_no >= portmap_lo_port) && (port_no < portmap_lo_port + portmap_range))
    {
     /* This user has arrived from a port with a fixed user mapping */

     i = portmap_lo_user + port_no - portmap_lo_port;

     if (*(UMap(i))) return 0;

     *(UMap(i)) = user_table_index;
     return i;
    }
  }

 /* Starting at the next user number in cyclic order, find the first
    available user number (there must be one).                        */

 i = sysseg->last_user;
 hi = sysseg->hi_user_no;
 do {
     i = (i % hi) + 1;
     if ((i >= portmap_lo_user) && (i <= portmap_hi_user))
      {
       /* Skip reserved ports */
       i = (portmap_hi_user % hi) + 1;
      }
     else if ((i >= fixusers_lo_user) && (i <= fixusers_hi_user))
      {
       /* Skip reserved ports */
       i = (fixusers_hi_user % hi) + 1;
      }
    } while(*(UMap(i)));

 sysseg->last_user = i;
 *(UMap(i)) = user_table_index;

 return i;
}

/* ======================================================================
   Kernel                                                                 */

void kernel()
{
 long int retained_flags;
 char processor[MAX_PROGRAM_NAME_LEN+1];
 bool aborting = FALSE;

 signal(SIGSEGV, fatal_signal_handler);
 signal(SIGILL, fatal_signal_handler);

 signal(SIGBUS, fatal_signal_handler);
 signal(SIGCHLD, sigchld_handler);
 signal(SIGUSR1, sigusr1_handler);


 /* Call the command processor in the new process */

 k_call(command_processor, 0, NULL);

 if (setjmp(k_exit))          /* Abort, Quit, Logout */
  {
   unwind_stack();                     /* Tidy up e-stack */
   process.for_init = FALSE;           /* Not initialising FOR loop */
   process.op_flags = 0;               /* Clear opcode prefix flags */
   retained_flags = 0;

   switch(k_exit_cause)
    {
     case K_ABORT:
        if (my_uptr->lockwait_index) clear_lockwait();
        txn_abort();
        clear_select(0);
        collation = primary_collation;  /* Clear down use of AK collation map */
        aborting = TRUE;
        process.k_abort_code = 1;     /* Set @ABORT.CODE */
        break;

     case K_QUIT:
        process.k_abort_code = 2;     /* Set @ABORT.CODE */
        break;

     case K_TERMINATE:                /* Forced logout of process */
        txn_abort();
        /* Cast off all but bottom level process (which must be a command
           processor), decrementing command level for each stacked processor */

        while(process.call_depth > 1)
         {
          if (process.program.flags & HDR_IS_CPROC) cproc_level--;
          k_return();
         }
        process.k_abort_code = 3;     /* Set @ABORT.CODE */
        break;

     case K_LOGOUT:                   /* Immediate termination of process */
        txn_abort();
        kill_process();
        goto exit_kernel;
    }

   k_exit_cause = 0;

   /* Cast off all programs down to and including one with the HDR_IS_CPROC
      flag set. Then re-call the same processor, retaining the IS_EXECUTE
      and IGNORE_ABORTS flags from the aborted command processor.           */

   while(!(process.program.flags & HDR_IS_CPROC))
    {
     k_return();
    }

   if (aborting)
    {
     aborting = FALSE;
     if (capturing)
      {
       if (capture_head != NULL)
        {
         s_free(capture_head);
         capture_head = NULL;
        }
       capturing = FALSE;          /* 0117 Target variable has gone... */
       unstack_display_pu();
      }
     rtnlist = FALSE;              /* ...so has RTNLIST variable */
   }

   retained_flags = process.program.flags & (IS_EXECUTE | IGNORE_ABORTS);
   strcpy(processor, ((OBJECT_HEADER *)c_base)->ext_hdr.prog.program_name);

   k_return();

   k_call(processor, 0, NULL);

   process.program.flags |= retained_flags;
  }

 recursion_depth = -1;
 k_run_program();

exit_kernel:
 como_close();

 return;
}

/* ======================================================================
   kill_process()  -  Remove process                                      */

private void kill_process()
{
 USER_ENTRY * uptr;
 short int i;

 /* Release task locks owned by this process */

 for (i = 0; i < 64; i++)
  {
   if (sysseg->task_locks[i] == process.user_no) sysseg->task_locks[i] = 0;
  }

 /* Give away process resources */

 unwind_stack();                     /* Release all e-stack variables */

 k_free(e_stack_base);               /* Free e-stack memory */

 while(process.call_depth)           /* Unwind program levels */
  {
   k_return();
  }

 free_common(process.named_common);

 free_print_units();

 como_close();                       /* Close any como file and free buffer */

 StartExclusive(SHORT_CODE, 22);


 /* Release licence */

 *(UMap(my_uptr->uid)) = 0;
 my_uptr->uid = 0;
 my_uptr->puid = 0;

 /* Also, clear parent user id from any phantoms started by this process */

 for (i = 1; i <= sysseg->max_users; i++)
  {
   uptr = UPtr(i);
   if (uptr->puid == process.user_no)
    {
     uptr->puid = 0;
    }
  }

 EndExclusive(SHORT_CODE);
}


/* ======================================================================
   k_run_program()  -  Dispatch loop                                      */

void k_run_program() /* Returns FALSE if aborts */
{
 k_exit_cause = 0;
 recursion_depth++;

 do {
       while(!k_exit_cause)
        {
         dispatch[*(op_pc = pc++)]();
        }

     switch(k_exit_cause)
      {
       case K_CHAIN_PROC:
          if (my_uptr->lockwait_index) clear_lockwait();

          if (recursion_depth)
           {
            if (!(process.program.flags & (HDR_ITYPE | HDR_IS_CLASS)))
             {
              k_error("Termination in recursive code");
             }
           }

          /* Cast off all programs down to but not including one with
             the HDR_IS_CPROC flag set.                               */

          while(!(process.program.flags & HDR_IS_CPROC))
           {
            k_return();
           }

          k_exit_cause = 0;
          break;

       case K_STOP:
          if (my_uptr->lockwait_index) clear_lockwait();

          if (recursion_depth)
           {
            if (!(process.program.flags & (HDR_ITYPE | HDR_IS_CLASS)))
             {
              k_error("Termination in recursive code");
             }
           }

          /* Cast off all programs down to but not including one with
             the HDR_IS_CPROC or IS_CLEXEC flag set.                    */

          while(!(process.program.flags & (HDR_IS_CPROC | IS_CLEXEC)))
           {
            k_return();
           }

          if (process.program.flags & IS_CLEXEC) k_return();   /* 0510 */

          k_exit_cause = 0;
          break;

       case K_CHAIN:
          if (my_uptr->lockwait_index) clear_lockwait();

          if (recursion_depth)
           {
            if (!(process.program.flags & (HDR_ITYPE | HDR_IS_CLASS)))
             {
              k_error("Termination in recursive code");
             }
           }

          /* Cast off all programs down to but not including one with
             the HDR_IS_CPROC flag set.                               */

          while(!(process.program.flags & HDR_IS_CPROC))
           {
            k_return();
           }

          k_exit_cause = 0;
          break;

       case K_ABORT:
       case K_LOGOUT:
       case K_TERMINATE:
          if (my_uptr->lockwait_index) clear_lockwait();
          Element(process.syscom, SYSCOM_ITYPE_MODE)->data.value = 0;
          longjmp(k_exit, k_exit_cause);
          break;

       case K_RETURN:
          if (process.program.prev == NULL)    /* Final return */
           {
            goto exit_run_program;   /* The end */
           }
          else
           {
            k_exit_cause = 0;
            k_return();
           }
          break;

       case K_QUIT:       /* Quit handler activated */
          break_pending = FALSE;
          if (!tio_handle_break())
           {
            longjmp(k_exit, k_exit_cause);
           }
          break;

       case K_EXIT_RECURSIVE:
          goto exit_run_program;

       case K_TOGGLE_TRACER:    /* Change in trace or monitor mode setting */
          k_exit_cause = 0;
          break;
      }
    } while((k_exit_cause == 0)
         || (k_exit_cause == K_QUIT));

exit_run_program:
 if (--recursion_depth == 0)  /* Returning from outermost recursive code */
  {
   if (break_pending && !process.break_inhibits)
    {
     k_exit_cause = K_QUIT;
    }
  }

 return;
}

/* ======================================================================
   op_prefix()  -  Secondary dispatch                                     */

void op_prefix()
{
 dispatch[256 + *(pc++)]();
}

/* ======================================================================
   k_return()  -  Return to previous call level                           */

void k_return()
{
 struct PROGRAM * prg;
 unsigned long old_flags;
 OBJECT_HEADER * obj_hdr;


 k_release_vars();                     /* 0495 Release local variables */

 obj_hdr = (OBJECT_HEADER *)c_base;
 if ((obj_hdr->id == 0) /* Return from recursive program */
    || (process.program.flags & (PF_IS_TRIGGER | PF_IS_VFS | HDR_IS_CLASS)))
  {
   k_exit_cause = K_EXIT_RECURSIVE;
  }
 else
  {
   if ((--(obj_hdr->ext_hdr.prog.refs) == 0) && (obj_hdr->id < 0)) /* Expired runfile */
    {
     unload_object((void *)obj_hdr);
    }
  }

 old_flags = process.program.flags;

 if ((prg = process.program.prev) != NULL)
  {
   /* Look for a stacked EXECUTE...CAPTURING construct.
      This has to be because the executed program stopped or aborted
      and hence we did not execute the CAPTURE opcode in the parent program.
      Discard any data collected at the current level and reinstate the
      previous capture string.                                              */

   if (process.program.flags & PF_CAPTURING)
    {
     if (capturing)  /* Probably must be true */
      {
       s_free(capture_head);
      }

     capture_head = process.program.saved_capture_head;
     capture_tail = process.program.saved_capture_tail;
     capturing = TRUE;
    }

   process.program = *prg;
   k_free((void *)prg);
   c_base = process.program.saved_c_base;
   pc = c_base + process.program.saved_pc_offset;
  }
 else
  {
   init_program();
   process.program.flags = 0;
   c_base = NULL;
  }

 if (hsm) hsm_enter();

 if (--process.call_depth == 0)  /* Exit from bottom level */
  {
   k_exit_cause = K_LOGOUT;
  }

 if (old_flags & SORT_ACTIVE)
  {
   op_sortclr();
  }

 if (old_flags & IS_EXECUTE)
  {
   tio.prompt_char = process.program.saved_prompt_char;
  }

 if (old_flags & HDR_IS_DEBUGGER)
  {
   /* Returning from debugger to program being debugged.
      Restore saved items from process structure.        */

   process.status = debug_status;
   process.inmat = debug_inmat;
   tio.suppress_como = debug_suppress_como;
   tio.hush = debug_hush;
   capturing = debug_capturing;
   tio.prompt_char = debug_prompt_char;
   tio.dsp.line = debug_dsp_line;
   if (debug_dsp_paginate) tio.dsp.flags |= PU_PAGINATE;
   else tio.dsp.flags &= ~PU_PAGINATE;
   in_debugger = FALSE;
  }
 else  /* Not returning from debugger to program being debugged */
  {
  }
}

/* ======================================================================
   k_call()  -  Call program

   If the code_ptr argument is null, we perform a search for this object
   name.  Otherwise we simply call the object at that address.             */


void k_call(name, num_args, code_ptr)
   char * name;
   int num_args;
   u_char * code_ptr;  /* For in-line code items */
{
 struct OBJECT_HEADER * hdr;
 unsigned int mem_reqd;
 int i;
 DESCRIPTOR * p;
 DESCRIPTOR * q;
 DESCRIPTOR * new_stack;
 struct PROGRAM * prg;
 int new_stack_depth;


 if (process.call_depth == pcfg.maxcall) k_error(sysmsg(1140)); /* CALLs nested too deeply */

 /* Find the program. We omit this step for recursive calls as the program
    pointers will already be set.                                          */

 if (code_ptr == NULL)   /* Dynamically loaded object */
  {
   hdr = (OBJECT_HEADER *)load_object(name, FALSE);
   if (hdr == NULL) k_error(sysmsg(1002), name);
   hdr->ext_hdr.prog.refs++;

   if (hdr->flags & HDR_IS_CLASS)
    {
     k_error(sysmsg(3450)); /* A CLASS routine may not be used in this way */
    }
  }
 else                   /* In-line object, recursive or call via SUBR */
  {
   hdr = (struct OBJECT_HEADER *)code_ptr;
  }

 if (c_base != NULL)
  {
   /* Save previous PROGRAM state */

   prg = (struct PROGRAM *)k_alloc(18,sizeof(struct PROGRAM));
   if (prg == NULL) k_error(sysmsg(1003));
   process.program.saved_pc_offset = pc - c_base;
   process.program.saved_prompt_char = tio.prompt_char;
   *prg = process.program;
   process.program.prev = prg;
  
   process.program.flags &= FLAG_COPY_MASK;
  }
 else
  {
   process.program.flags = 0;
  }

 process.call_depth++;
 init_program();

 c_base = (u_char *)hdr;
 process.program.saved_c_base = c_base;
 if (hsm) hsm_enter();

 /* Find start of program execution */

 pc = c_base + hdr->start_offset;

 /* Allocate descriptor area */

 process.program.no_vars = hdr->no_vars;
 if (process.program.no_vars == 0)
  {
   process.program.vars = NULL;
  }
 else
  {
   mem_reqd = process.program.no_vars * sizeof(DESCRIPTOR);
 
   process.program.vars = (DESCRIPTOR *)k_alloc(19,mem_reqd);
   if (process.program.vars == NULL)
    {
     /* Insufficient memory for program variables */
     k_error(sysmsg(1004));
    }
 
   for (i = 0, p = process.program.vars; i < process.program.no_vars; i++, p++)
    {
     InitDescr(p, UNASSIGNED);
    }
  }

 if ((hdr->flags & HDR_VAR_ARGS)?(num_args > hdr->args):(num_args != hdr->args))
  {
   /* Argument count mismatch */
   k_return();   /* Return to caller so that message relates to CALL */
   k_error(sysmsg(1005),
           ((name == NULL) || (*name == '\0'))?ProgramName(hdr):name,
             num_args, hdr->args);
  }

 process.program.arg_ct = num_args;
 if (num_args)
  {
   /* Copy arguments currently on e-stack into new vars */

   for (i = num_args, p = e_stack - num_args, q = process.program.vars; i > 0; i--)
    {
     *q = *(p++);
     q->flags |= DF_ARG;
     q++;
    }
   e_stack -= num_args; /* Remove from e-stack. Do not release as copied */
  }


 /* Ensure evaluation stack is big enough (0280)
    The program header includes an estimate of the depth needed to run this
    program. This should never be too low though the compiler doesn't do
    full stack tracking yet. Add a little extra to allow for pushing
    arguments to recursives.                                                */

 if (e_stack_depth < hdr->stack_depth + (e_stack - e_stack_base) + 10)
  {
   new_stack_depth = e_stack_depth + hdr->stack_depth + 10;

   /* Allocate new stack */

   mem_reqd = new_stack_depth * sizeof(DESCRIPTOR);
   new_stack = (DESCRIPTOR *)k_alloc(20,mem_reqd);
   if (new_stack == NULL) /* Insufficient memory for stack */
    {
     k_error(sysmsg(1006));
    }

   e_stack_depth = new_stack_depth;

   for (i = e_stack_depth, p = new_stack; i--; p++)
    {
     InitDescr(p, UNASSIGNED);
    }

   /* Copy any existing e-stack items and free old stack */

   p = e_stack;     /* Old stack */
   e_stack = new_stack;
   if (p != NULL)
    {
     i = p - e_stack_base;
     q = e_stack_base;
     while(i--) *(e_stack++) = *(q++);

     k_free((void *)e_stack_base);
    }

   e_stack_base = new_stack;
  }

 /* Set flags */

 process.program.flags |= hdr->flags;
}

/* ======================================================================
   k_recurse()  -  Execute recursive program                              */

void k_recurse(code_ptr, num_args)
   u_char * code_ptr;
   int num_args;
{
 /* Set up to run recursive code */

 k_call("", num_args, code_ptr);

 /* Execute program */

 k_run_program();

 /* Ensure that we reassess trace mode in the lower layer */
 if (k_exit_cause == K_EXIT_RECURSIVE) k_exit_cause = K_TOGGLE_TRACER;
}

/* ======================================================================
   k_recurse_object()  -  Execute recursive CLASS object program          */

void k_recurse_object(code_ptr, num_args, objdata)
   u_char * code_ptr;
   int num_args;
   OBJDATA * objdata;
{
 /* Set up to run recursive code */

 k_call("", num_args, code_ptr);
 process.program.objdata = objdata;
 k_run_program(); /* Execute program */

 /* Ensure that we reassess trace mode in the lower layer */
 if (k_exit_cause == K_EXIT_RECURSIVE) k_exit_cause = K_TOGGLE_TRACER;
}

/* ======================================================================
   Unwind the evaluation stack at error or on killing process             */

private void unwind_stack()
{
 if (e_stack_depth)
  {
   while(e_stack != e_stack_base)
    {
     k_dismiss();
    }
  }
}

/* ======================================================================
   k_release_vars()  -  Unwind var stack prior to return from long call   */

private void k_release_vars()
{
 int i;
 DESCRIPTOR * p;

 if (process.program.vars != NULL)
  {
   /* Release memory for all variables at this level */

   for (i = 0, p = process.program.vars; i < process.program.no_vars; i++, p++)
    {
     /* Cancel debugger watch */
     if (p == watch_descr) watch_descr = NULL;

     /* Release all memory hung off descriptors */
     k_release(p);
    }

   k_free((void *)process.program.vars);
   process.program.vars = NULL;
  }
}

/* ======================================================================
   raise_event()  -  Raise event in one/all processes                     */

bool raise_event(event, user)
   short int event;             /* Event to raise */
   short int user;              /* User number. -ve to raise in all users */
{
 bool status = FALSE;
 USER_ENTRY * uptr;
 short int u;

 StartExclusive(SHORT_CODE, 65);

 for (u = 1; u < sysseg->max_users; u++)
  {
   uptr = UPtr(u);
   if (uptr->uid)
    {
     if ((uptr->uid == user) || (user < 0))
      {
       uptr->events |= event;
       if (event & (EVT_LOGOUT | EVT_TERMINATE | EVT_LICENCE))
        {
         uptr->flags |= USR_LOGOUT;
        }
       status = TRUE;
       if (user >= 0) break;
      }
    }
  }

 EndExclusive(SHORT_CODE);

 return status;
}

/* ======================================================================
   process_events()  -  Process events from USER_ENTRY events word        */

void process_events()
{
 short int events;
 STRING_CHUNK * str;
 DESCRIPTOR * ipc_descr;       /* SYSCOM IPC.F file variable... */
 FILE_VAR * fvar;              /* ...its FVAR and... */
 DH_FILE * dh_file;            /* ...its DH_FILE structure */
 char id[16+1];
 static unsigned short int event_mask = 0xFFFF;
 unsigned short int defered_events;
 long int saved_status;
 long int saved_os_error;
 long int saved_inmat;
 bool saved_suppress_como;
 bool saved_capturing;
 bool saved_hush;
 long int saved_dsp_line;
 bool saved_dsp_paginate;

 /* Take a copy of the event flags and clear all events */

 StartExclusive(SHORT_CODE, 24);
 events = my_uptr->events & event_mask;
 defered_events = my_uptr->events & ~event_mask;
 my_uptr->events &= ~events;
 EndExclusive(SHORT_CODE);
  
 if (events & (EVT_LOGOUT | EVT_LICENCE))   /* Terminate process immediately */
  {
   if (events & EVT_LICENCE)
    {
     tio_printf("\n\nLicence expired\n\n");
     Sleep(3000);
    }
   k_exit_cause = K_LOGOUT;
   return;   /* Ignore any other events */
  }

 if (events & EVT_TERMINATE)           /* Terminate process gracefully */
  {
   k_exit_cause = K_TERMINATE;
   return;   /* Ignore any other events */
  }

 if (events & EVT_STATUS)              /* Status dump */
  {
   dump_status();
  }

 if (events & EVT_UNLOAD)              /* Unload inactive cached object code */
  {
   unload_all();
  }

 if (events & EVT_BREAK)               /* Clear break inhibit counter */
  {
   process.break_inhibits = 0;
  }

 if (events & EVT_HSM_ON)              /* Enable HSM in this process */
  {
   hsm_on();
  }

 if (events & EVT_HSM_DUMP)            /* Return HSM data */
  {
   ipc_descr = Element(process.syscom, SYSCOM_IPC);
   if ((ipc_descr->type == FILE_REF)
     && ((fvar = ipc_descr->data.fvar) != NULL)
     && ((dh_file = fvar->access.dh.dh_file) != NULL))
    {
     str = hsm_dump();
     sprintf(id, "H%d", (int)process.user_no);
     dh_write(dh_file, id, strlen(id), str);
     s_free(str);
    }
  }

 if (events & EVT_PDUMP)              /* Force process dump */
  {
   pdump();
  }

 if (events & EVT_FLUSH_CACHE)        /* Flush DH cache */
  {
   flush_dh_cache();
  }


 if (events & EVT_MESSAGE)           /* Send immediate message */
  {
   /* Save items from process structure that must not be trampled on by
      the recursive code.                                               */

   saved_status = process.status;
   saved_os_error = process.os_error;
   saved_inmat = process.inmat;
   saved_suppress_como = tio.suppress_como;    tio.suppress_como = TRUE;
   saved_capturing = capturing;                capturing = FALSE;
   saved_hush = tio.hush;                      tio.hush = FALSE;
   saved_dsp_line = tio.dsp.line;
   saved_dsp_paginate = (tio.dsp.flags & PU_PAGINATE) != 0;
   tio.dsp.flags &= ~PU_PAGINATE;

   event_mask &= ~EVT_MESSAGE;
   k_recurse(pcode_message, 0);
   event_mask |= EVT_MESSAGE;

   /* Now restore all the things we saved */

   process.status = saved_status;
   process.os_error = saved_os_error;
   process.inmat = saved_inmat;
   tio.suppress_como = saved_suppress_como;
   capturing = saved_capturing;
   tio.hush = saved_hush;
   tio.dsp.line = saved_dsp_line;
   if (saved_dsp_paginate) tio.dsp.flags |= PU_PAGINATE;
  }

 my_uptr->events |= defered_events;
}

/* ======================================================================
   account()  -  Return account name pointer                              */

u_char * account()
{
 DESCRIPTOR * syscom_descr;
 static u_char account_name[MAX_ACCOUNT_NAME_LEN + 1];

 /* Find WHO in SYSCOM */

 syscom_descr = Element(process.syscom, SYSCOM_WHO);
 (void)k_get_c_string(syscom_descr, account_name, MAX_ACCOUNT_NAME_LEN);
 return account_name;
}

/* ======================================================================
   show_stack()  -  Stack report                                          */

void show_stack()
{
 struct PROGRAM * prg;
 long int offset;
 short int i;
 int line;

 prg = &(process.program);
 offset = pc - c_base;
    do {
        line = k_line_no(offset, prg->saved_c_base);
        if (line < 0)
         {
          tio_printf("%s (%08lX)\n",
                     ProgramName(prg->saved_c_base), offset);
         }
        else
         {
          tio_printf("%s %d (%08lX)\n",
                     ProgramName(prg->saved_c_base), line, offset);
         }

        /* Local gosub return pointers
           Back up to point to GOSUB rather than to return address */

        for(i = prg->gosub_depth - 1; i >= 0; i--)
         {
          offset = prg->gosub_stack[i] - 1;  /* Back up to GOSUB (etc) */
          line = k_line_no(offset, prg->saved_c_base);
          if (line < 0) tio_printf("  (%08lX)\n", offset);
          else tio_printf("  %d (%08lX)\n", line, offset);
         }

        if ((prg = prg->prev) == NULL) break;

        offset = prg->saved_pc_offset - 1;  /* Back up into CALL */
       } while(1);
}


/* ======================================================================
   dump_status()  -  Handle status dump event

   F1 = userno VM pid VM flags
   F2 = command
   F3 = program stack
           {name {SM offset TM line ...}VM name etc...}
   F4 = Lock wait : user VM filepath VM id
   F5 = account
*/

private void ev_printf(char * template, ...);
private STRING_CHUNK * ev_head;
private STRING_CHUNK * ev_tail;

private void dump_status()
{
 DESCRIPTOR * ipc_descr;       /* SYSCOM IPC.F file variable... */
 FILE_VAR * fvar;              /* ...its FVAR and... */
 DH_FILE * dh_file;            /* ...its DH_FILE structure */
 char id[16+1];
 struct PROGRAM * prg;
 long int offset;
 short int i;
 STRING_CHUNK * str;
 RLOCK_ENTRY * lptr;
 FILE_ENTRY * fptr;

 ev_head = NULL;
 ev_tail = NULL;

 ipc_descr = Element(process.syscom, SYSCOM_IPC);
 if ((ipc_descr->type != FILE_REF)
   || ((fvar = ipc_descr->data.fvar) == NULL)
   || ((dh_file = fvar->access.dh.dh_file) == NULL)) return;


 /* Be brutal - Lock everything in sight */

 StartExclusive(FILE_TABLE_LOCK,57);
 StartExclusive(REC_LOCK_SEM,57);
 StartExclusive(GROUP_LOCK_SEM,57);
 StartExclusive(SHORT_CODE,57);

 /* Field 1  -  User (process) information */

 ev_printf("%d%c%d%c%d%c",
         (int)process.user_no,          /* TM process number */
         VALUE_MARK,
         (int)(my_uptr->pid),           /* OS process number */
         VALUE_MARK,
         (int)(my_uptr->flags),         /* Process flags */
         FIELD_MARK);

 /* Field 2  -  Command */

 str = Element(process.syscom, SYSCOM_LAST_COMMAND)->data.str.saddr;
 while(str != NULL)
  {
   ev_printf("%.*s", (int)(str->bytes), str->data);
   str = str->next;
  }
 ev_printf("%c", FIELD_MARK);

 /* Field 3  -  Call stack */

 if (c_base != NULL)
  {
   prg = &(process.program);

   /* Set up current location.
      The event processor has been called from some opcode, usually a jump.
      At this point, PC will probably point one byte beyond the opcode.
      Back it up by one byte.                                               */

   offset = pc - c_base - 1;
   do {
       ev_printf("%s%c%d%c%d",
               ProgramName(prg->saved_c_base),
               SUBVALUE_MARK,
               offset,
               TEXT_MARK,
               k_line_no(offset, prg->saved_c_base));

       /* Local gosub return pointers
          Back up to point to GOSUB rather than to return address */

       for(i = prg->gosub_depth - 1; i >= 0; i--)
        {
         offset = prg->gosub_stack[i] - 1;  /* Back up to GOSUB (etc) */
         ev_printf("%c%d%c%d",
                 SUBVALUE_MARK,
                 offset,
                 TEXT_MARK,
                 k_line_no(offset, prg->saved_c_base));
        }

       if ((prg = prg->prev) == NULL) break;

       offset = prg->saved_pc_offset - 1;  /* Back up into CALL */
       ev_printf("%c", VALUE_MARK);
      } while(1);
  }

 ev_printf("%c", FIELD_MARK);

 /* Field 4  -  Lock wait data */

 if ((i = my_uptr->lockwait_index) != 0)
  {
   if (i > 0)    /* Waiting for record lock */
    {
     lptr = RLPtr(i);
     ev_printf("%d%c%s%c%.*s",
               lptr->owner,
               VALUE_MARK,
               FPtr(lptr->file_id)->pathname,
               VALUE_MARK,
               lptr->id_len, lptr->id);
    }
   else          /* Waiting for file lock */
    {
     fptr = FPtr(-i);
     ev_printf("%d%c%s%c",
               abs(fptr->file_lock),
               VALUE_MARK,
               fptr->pathname,
               VALUE_MARK);
    }
  }

 /* Field 5  -  Account name */

 ev_printf("%c%s", FIELD_MARK, account());

 EndExclusive(SHORT_CODE);
 EndExclusive(GROUP_LOCK_SEM);
 EndExclusive(REC_LOCK_SEM);
 EndExclusive(FILE_TABLE_LOCK);

 sprintf(id, "S%d", (int)process.user_no);
 dh_write(dh_file, id, strlen(id), ev_head);
 s_free(ev_head);
}

private void ev_printf(char * template, ...)
{
 char s[500];
 va_list arg_ptr;
 short int len;
 short int bytes_to_move;
 short int bytes_remaining;
 char * p;

 if (ev_head == NULL)   /* First call */
  {
   ev_head = s_alloc(512, &bytes_remaining);
   ev_head->ref_ct = 1;
   ev_head->string_len = 0;
   ev_tail = ev_head;
  }
 else bytes_remaining = ev_tail->alloc_size - ev_tail->bytes;


 va_start(arg_ptr, template);

 len = vsprintf(s, template, arg_ptr);
 p = s;
 while (len > 0)
  {
   /* Allocate new chunk if the current one is full */

   if (bytes_remaining == 0)
    {
     ev_head->string_len += ev_tail->bytes;
     ev_tail->next = s_alloc(512, &bytes_remaining);
     ev_tail = ev_tail->next;
    }

   /* Copy what will fit into current chunk */

   bytes_to_move = min(bytes_remaining, len);
   memcpy(ev_tail->data + ev_tail->bytes, p, bytes_to_move);
   p += bytes_to_move;
   ev_tail->bytes += bytes_to_move;
   ev_head->string_len += bytes_to_move;
   len -= bytes_to_move;
   bytes_remaining -= bytes_to_move;
  }

 va_end(arg_ptr);

}

/* ======================================================================
   SIGCHLD handler                                                        */

void sigchld_handler(int signum)
{
 int pid;
 int status;
 int stacked_errno;

 stacked_errno = errno;
 do {
     pid = waitpid(-1, &status, WNOHANG);
    } while (pid > 0);
 errno = stacked_errno;

#ifdef SVID
 signal(SIGCHLD, sigchld_handler);
#endif
}

/* ======================================================================
   SIGUSR1 handler                                                        */

void sigusr1_handler(int signum)
{
 return;
}

/* ======================================================================
   op_kernel()  -  KERNEL()  -  Miscellaneous kernel functions            */

void op_kernel()
{
 /* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top |  Qualifier                     |  Result                     |
     |--------------------------------|-----------------------------|
     |  Action key                    |                             |
     |================================|=============================|
     
   Keys:
     K$INTERNAL           Set or clear internal mode
     K$INTERNAL.QUERY     Query internal mode
     K$PAGINATE           Test or modify pagination flag
     K$FLAGS              Test/return program header flags
     K$DATE.FORMAT        European date format?
     K$CRTWIDE            Return display width
     K$CRTHIGH            Return display lines per page
     K$SET.DATE           Set current date
     K$IS.PHANTOM         Is this a phantom process
     K$TERM.TYPE          Terminal type name
     K$USERNAME           User name
     K$DATE.CONV          Set default date conversion
     K$PPID               Get parent process id
     K$USERS              Get user list
     K$INIPATH            Get ini file pathname
     K$FORCED.ACCOUNT     Force entry to named account unless set in $LOGINS
     K$TMNET              Get/set TMNet status flag
     K$CPROC.LEVEL        Get/set command processor level
     K$HELP               Invoke help system
     K$SUPPRESS.COMO      Supress/resume como file output
     K$ADMINISTRATOR      Get/set administrator rights
     K$SECURE             Secure system?
     K$GET.OPTIONS        Get options flags
     K$SET.OPTIONS        Set options flags
     K$PRIVATE.CATALOGUE  Set private catalogue pathname
     K$CLEANUP            Clean up defunct users
     K$COMMAND.OPTIONS    Get command line option flags
     K$CASE.SENSITIVE     REMOVE.TOKEN() cases sensitivity
     K$SET.LANGUAGE       Set language for message handler
     K$COLLATION          Set/clear sort collation data
     K$GET.TMNET.CONNECTIONS  Get details of open TMNet connections
     K$INVALIDATE.OBJECT  Invalidate object cache
     K$MESSAGE            Enable/disable message reception
     K$SET.EXIT.CAUSE     Set k_exit_cause
     K$COLLATION.NAME     Set primary collation map name
     K$AK.COLLATION       Select AK collation map
     K$EXIT.STATUS        Set exit status
     K$AUTOLOGOUT         Set/retrieve autologout period
     K$MAP.DIR.IDS        Enable/disable dir file id mapping
 */

 DESCRIPTOR * descr;
 int action;
 DESCRIPTOR result;
 long int n;
 char s[MAX_PATHNAME_LEN+1];
 short int i;
 short int j;
 USER_ENTRY * uptr;
 long int * q;
 STRING_CHUNK * str;

 InitDescr(&result, INTEGER);
 result.data.value = 0;

 descr = e_stack - 2;
 GetInt(descr);
 action = descr->data.value;

 descr = e_stack - 1;
 k_get_value(descr);

 switch(action)
  {
   case K_INTERNAL:
      GetInt(descr);
      if (descr->data.value < 0) result.data.value = internal_mode;
      else internal_mode = descr->data.value;
      break;

   case K_SECURE:
      GetInt(descr);
      if (descr->data.value < 0)
       {
        if (is_nt) result.data.value = TRUE;
        else result.data.value = ((sysseg->flags & SSF_SECURE) != 0);
       }
      else
       {
        if (descr->data.value) sysseg->flags |= SSF_SECURE;
        else sysseg->flags &= ~SSF_SECURE;
       }
      break;

   case K_LPTRHIGH:  /* Same as SYSTEM(3) */
      if (process.program.flags & PF_PRINTER_ON) result.data.value = tio.lptr_0.lines_per_page;
      else result.data.value = tio.dsp.lines_per_page;
      break;

   case K_LPTRWIDE:  /* Same as SYSTEM(2) */
      if (process.program.flags & PF_PRINTER_ON) result.data.value = tio.lptr_0.width;
      else result.data.value = tio.dsp.width;
      break;

   case K_PAGINATE:
      if ((n = descr->data.value) < 0)   /* Enquiry */
       {
        result.data.value = (tio.dsp.flags & PU_PAGINATE) != 0;
       }
      else                               /* Set pagination state */
       {
        if (n)
         {
          tio.dsp.flags |= PU_PAGINATE;
          tio.dsp.line = 0;
         }
        else
         {
          tio.dsp.flags &= ~PU_PAGINATE;
         }
       }
      break;

   case K_FLAGS:
      GetInt(descr);
      n = descr->data.value;
      if (n) result.data.value = ((process.program.flags & n) != 0);
      else result.data.value = process.program.flags;
      break;

   case K_DATE_FORMAT:
      GetInt(descr);
      n = descr->data.value;
      if (n >= 0) european_dates = (n != 0);
      result.data.value = european_dates;
      break;

   case K_CRTHIGH:
      result.data.value = tio.dsp.lines_per_page;
      break;

   case K_CRTWIDE:
      result.data.value = tio.dsp.width;
      break;

   case K_SET_DATE:
      GetInt(descr);
      set_date(descr->data.value);
      break;

   case K_IS_PHANTOM:
      result.data.value = is_phantom;
      break;

   case K_TERM_TYPE:
      k_get_string(descr);
      if (descr->data.str.saddr != NULL)
       {
        k_get_c_string(descr, s, 32);
        settermtype(s);
       }
      k_put_c_string(tio.term_type, &result);
      break;

   case K_USERNAME:
      k_get_string(descr);
      if (descr->data.str.saddr != NULL)
       {
        k_get_c_string(descr, (char *)(my_uptr->username), MAX_USERNAME_LEN);
       }
      k_put_c_string((char *)(my_uptr->username), &result);
      break;

   case K_DATE_CONV:
      if ((result.data.value = (k_get_c_string(descr, s, 32))) > 0)
       {
        strcpy(default_date_conversion, s);
       }
      k_put_c_string((char *)(default_date_conversion), &result);
      break;

   case K_PPID:
      result.data.value = my_uptr->puid;
      break;

   case K_USERS:
      GetInt(descr);
      n = descr->data.value;   /* User number or zero for all */
      InitDescr(&result, STRING);
      result.data.str.saddr = NULL;
      ts_init(&(result.data.str.saddr), 128);
      for(i = 1; i <= sysseg->max_users; i++)
       {
        uptr = UPtr(i);
        if (((n == 0) && (uptr->uid > 0))  || ((n != 0) && (uptr->uid == n)))
         {
          if (result.data.str.saddr != NULL) ts_copy_byte(FIELD_MARK);
          ts_printf("%d%c%ld%c%s%c%d%c%d%c%s%c%s",
                  (int)(uptr->uid), VALUE_MARK,
                  (int)(uptr->pid), VALUE_MARK,
                  uptr->ip_addr, VALUE_MARK,
                  (int)(uptr->flags), VALUE_MARK,
                  uptr->puid, VALUE_MARK,
                  uptr->username, VALUE_MARK,
                  uptr->ttyname);
          if (n) break;
         }
       }
      ts_terminate();
      break;


   case K_INIPATH:
      k_put_c_string(config_path, &result);
      break;


   case K_FORCED_ACCOUNT:
      k_put_c_string(forced_account, &result);
      break;
   
   case K_TMNET:
      if (descr->data.value < 0) result.data.value = ((my_uptr->flags & USR_TMNET) != 0);
      else if (descr->data.value) my_uptr->flags |= USR_TMNET;
      else my_uptr->flags &= ~USR_TMNET;
      break;

   case K_CPROC_LEVEL:
      if (descr->data.value > 0) cproc_level = descr->data.value;
      result.data.value = cproc_level;
      break;

   case K_HELP:
      if (k_get_c_string(descr, s, 200) >= 0) result.data.value = help(s);
      else result.data.value = -1;   /* Key too long */
      break;

   case K_SUPPRESS_COMO:
      if ((n = descr->data.value) < 0)   /* Enquiry */
       {
        result.data.value = (tio.suppress_como);
       }
      else                               /* Set suppression state */
       {
        tio.suppress_como = (n != 0);
       }
      break;

   case K_IS_TMVBSRVR:
      result.data.value = is_TMVbSrvr;
      break;

   case K_ADMINISTRATOR:
      GetInt(descr);
      n = descr->data.value;
      if (n >= 0)    /* Setting / clearing */
       {
        if ((n > 0) || IsAdmin()) my_uptr->flags |= USR_ADMIN;
        else my_uptr->flags &= ~USR_ADMIN;
       }
      result.data.value = (my_uptr->flags & USR_ADMIN) != 0;
      break;

   case K_FILESTATS:
      GetInt(descr);
      if (descr->data.value)  /* Reset counters */
       {
        memset((char *)&(sysseg->global_stats), 0, sizeof(struct FILESTATS));
        sysseg->global_stats.reset = tmtime();
       }
      else
       {
        InitDescr(&result, STRING);
        result.data.str.saddr = NULL;
        ts_init(&(result.data.str.saddr), 5 * FILESTATS_COUNTERS);
        for (i = 0, q = (long int *)&(sysseg->global_stats.reset); i < FILESTATS_COUNTERS; i++, q++)
         {
          ts_printf("%ld\xfe", *q);
         }
        (void)ts_terminate();
       }
      break;

   case K_TTY:
      k_put_c_string((char *)(my_uptr->ttyname), &result);
      break;

   case K_GET_OPTIONS:
      for(i = 0; i < NumOptions; i++) s[i] = option_flags[i] + '0';
      s[NumOptions] = '\0';
      k_put_c_string(s, &result);
      break;

   case K_SET_OPTIONS:
      j = k_get_c_string(descr, s, 200);
      for(i = 0; (i < j) && (i < NumOptions); i++) SetOption(i,s[i] == '1');
      break;

   case K_PRIVATE_CATALOGUE:
      j = k_get_c_string(descr, private_catalogue, MAX_PATHNAME_LEN);
      break;


   case K_CLEANUP:
      result.data.value = recover_users();
      break;

   case K_OBJKEY:
      result.data.value = object_key;
      break;

   case K_COMMAND_OPTIONS:
      result.data.value = command_options;
      break;

   case K_CASE_SENSITIVE:
      GetInt(descr);
      if (descr->data.value < 0) result.data.value = case_sensitive;
      else case_sensitive = descr->data.value;
      break;


   case K_SET_LANGUAGE:
      k_get_c_string(descr, s, 3);
      result.data.value = load_language(s);
      break;

   case K_HSM:
      GetInt(descr);
      switch(descr->data.value)
       {
        case 0:             /* Disable */
           hsm = FALSE;
           break;
        case 1:             /* Enable */
           hsm_on();
           break;
        case 2:             /* Return data */
           InitDescr(&result, STRING);
           result.data.str.saddr = hsm_dump();
           break;
       }
      break;

   case K_COLLATION:
      k_get_string(descr);
      if (descr->data.str.saddr == NULL)
       {
        primary_collation = NULL;
        collation = NULL;
       }
      else
       {
        str = s_make_contiguous(descr->data.str.saddr, NULL);
        descr->data.str.saddr = str;
        memcpy(primary_collation_map, str->data, 256);
        primary_collation = primary_collation_map;
        collation = primary_collation_map;
       }
      break;

   case K_GET_TMNET_CONNECTIONS:
      InitDescr(&result, STRING);
      result.data.str.saddr = get_tmnet_connections();
      break;


   case K_INVALIDATE_OBJECT:
      invalidate_object();
      break;

   case K_MESSAGE:
      GetInt(descr);
      n = descr->data.value;
      if (n == 0) my_uptr->flags |= USR_MSG_OFF;
      else if (n > 0) my_uptr->flags &= ~USR_MSG_OFF;
      result.data.value = (my_uptr->flags & USR_MSG_OFF) == 0;
      break;

   case K_SET_EXIT_CAUSE:
      GetInt(descr);
      k_exit_cause = descr->data.value;
      break;

   case K_COLLATION_NAME:
      settmstring(&collation_map_name, descr);
      break;

   case K_AK_COLLATION:
      if (descr->type == STRING)
       {
        str = descr->data.str.saddr;
        collation = (str == NULL)?NULL:str->data;
       }
      else collation = primary_collation;
      break;

   case K_EXIT_STATUS:
      GetInt(descr);
      exit_status = descr->data.value;
      break;

   case K_CASE_MAP:
      GetString(descr);
      if ((str = descr->data.str.saddr) == NULL) set_default_character_maps();
      else
       {
        uc_chars[str->data[1]] = str->data[0];
        lc_chars[str->data[0]] = str->data[1];
        char_types[str->data[0]] |= CT_ALPHA | CT_GRAPH;
        char_types[str->data[1]] |= CT_ALPHA | CT_GRAPH;
       }
      break;

   case K_AUTOLOGOUT:
      GetInt(descr);
      if (descr->data.value >= 0) autologout = descr->data.value;
      result.data.value = autologout;
      break;

   case K_MAP_DIR_IDS:
      GetInt(descr);
      if (descr->data.value >= 0) map_dir_ids = (descr->data.value != 0);
      result.data.value = map_dir_ids;
      break;

   default:
      k_error("Illegal KERNEL() action key (%d)", action);
  }

 k_dismiss();
 *(e_stack - 1) = result;
}

/* ======================================================================
   op_lgnport()  -  Login a serial port process                           */

void op_lgnport()
{
 /* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top | Account name                   |  Successful? (true/false)   |
     |--------------------------------|-----------------------------|
     | Port name{:params}             |                             |
     |================================|=============================|
 */


 bool status = FALSE;

  process.status = ER_UNSUPPORTED;

 k_dismiss();
 k_dismiss();

 InitDescr(e_stack, INTEGER);
 (e_stack++)->data.value = status;
}

/* ======================================================================
   op_option()  -  OPTION() function                                      */

void op_option()
{
/* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top |  Option number                 |  Option state               |
     |================================|=============================|
 */


 DESCRIPTOR * descr;
 int opt;

 descr = e_stack - 1;
 GetInt(descr);
 opt = descr->data.value;
 if ((opt >= 0) && (opt < NumOptions)) descr->data.value = Option(opt);
 else descr->data.value = 0;
}


/* ======================================================================
   op_phantom()  -  PHANTOM  -  Start new process                         */

void op_phantom()
{
 /* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top |                                |  TM user id, zero if fails  |
     |================================|=============================|
 */


 short int i;
 USER_ENTRY * uptr;
 short int phantom_user_index;
 short int phantom_uid;
 char path[MAX_PATHNAME_LEN+1];
 char option[15+1];
 int cpid;

 /* Reserve a user table entry for the phantom process */

 StartExclusive(SHORT_CODE, 38);
 phantom_user_index = 0;
 for (i = 1; i <= sysseg->max_users; i++)
  {
   uptr = UPtr(i);
   if (uptr->uid == 0)   /* Spare cell */
    {
     phantom_uid = assign_user_no(i);
     uptr->uid = phantom_uid;
     uptr->puid = process.user_no;
     strcpy((char *)(uptr->username), (char *)(my_uptr->username));
     phantom_user_index = i;
     break;
    }
  }
 EndExclusive(SHORT_CODE);

 if (phantom_user_index == 0) goto exit_op_phantom;

 /* Construct command for CreateProcess */


 cpid = fork();
 if (cpid == 0)    /* Child process */
  {
//0387   close(0);
//0387   close(1);
//0387   close(2);
   for (i = 3; i < 1024; i++) close(i);  /* 0401 */

   sprintf(path, "%s/bin/tm", sysseg->sysdir);
   sprintf(option, "-p%d", phantom_user_index);
   execl(path, path, option, NULL); 
  }
 else if (cpid == -1) /* Error */
  {
   *(UMap(uptr->uid)) = 0;
   uptr->uid = 0;            /* Release reserved user cell */
   uptr->puid = 0;
   phantom_uid = 0;
  }
 else   /* Parent process */
  {
   waitpid(cpid, NULL, WNOHANG);
  }

exit_op_phantom:
 InitDescr(e_stack, INTEGER);
 (e_stack++)->data.value = phantom_uid;
}

/* ======================================================================
   op_chgphant()  -  Make process a "chargeable" phantom                  */

void op_chgphant()
{
 /* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top |                                |  1 = ok, 0 = error          |
     |================================|=============================|
 */

 bool status = TRUE;


 InitDescr(e_stack, INTEGER);
 (e_stack++)->data.value = status;
}

/* ======================================================================
   op_cnctport()  -  CONNECT.PORT()                                        */

void op_cnctport()
{
 /* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top | Stop bits                      |  1 = ok, 0 = error          |
     |--------------------------------|-----------------------------|
     | Bits per byte                  |                             |
     |--------------------------------|-----------------------------|
     | Parity mode                    |                             |
     |--------------------------------|-----------------------------|
     | Baud rate                      |                             |
     |--------------------------------|-----------------------------|
     | Port name                      |                             |
     |================================|=============================|
 */

 DESCRIPTOR * descr;
 int stop_bits;
 int bits_per_byte;
 int parity;
 int baud_rate;
 char portname[20+1];

 process.status = ER_PARAMS;

 descr = e_stack - 1;
 GetInt(descr);
 stop_bits = descr->data.value;
 if ((stop_bits < 1) || (stop_bits > 20)) goto exit_op_cnctport;

 descr = e_stack - 2;
 GetInt(descr);
 bits_per_byte = descr->data.value;
 if ((bits_per_byte < 7) || (bits_per_byte > 8)) goto exit_op_cnctport;

 descr = e_stack - 3;
 GetInt(descr);
 parity = descr->data.value;

 descr = e_stack - 4;
 GetInt(descr);
 baud_rate = descr->data.value;

 descr = e_stack - 5;
 if (k_get_c_string(descr, portname, 20) < 1)
  {
   process.status = ER_LENGTH;
   goto exit_op_cnctport;
  }

 process.status = 0;


 /* This operation is only valid if we are a phantom process with a
    connection type of CN_NONE.                                      */

 if (!is_phantom)
  {
   process.status = ER_NOT_PHANTOM;
   goto exit_op_cnctport;
  }

 if (connection_type != CN_NONE)
  {
   process.status = ER_CONNECTED;
   goto exit_op_cnctport;
  }

  process.status = ER_UNSUPPORTED;

exit_op_cnctport:
 k_pop(4);
 k_dismiss();
 InitDescr(e_stack, INTEGER);
 (e_stack++)->data.value = (process.status == 0);
}

/* ======================================================================
   op_login()  -  LOGIN()  -  Perform login for socket based process      */

void op_login()
{
 /* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top |  Password                      |  1 = ok, 0 = error          |
     |--------------------------------|-----------------------------|
     |  User name                     |                             |
     |================================|=============================|
 */

 DESCRIPTOR * descr;
 char username[32+1];
 char password[32+1];

 /* Get password */

 descr = e_stack-1;
 (void)k_get_c_string(descr, password, 32);
 k_dismiss();

 /* Get username */

 descr = e_stack-1;
 (void)k_get_c_string(descr, username, 32);
 k_dismiss();

 InitDescr(e_stack, INTEGER);
 (e_stack++)->data.value = login_user(username, password);
}

/* ======================================================================
   op_logout()  -  LOGOUT()  -  Logout phantom process                    */

void op_logout()
{
 /* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top |  Immediate flag                |  1 = ok, 0 = error          |
     |--------------------------------|-----------------------------|
     |  User number                   |                             |
     |================================|=============================|
 */

 DESCRIPTOR * descr;
 int user;
 int status = 0;
 bool immediate;

 /* Get immediate flag */

 descr = e_stack - 1;
 GetBool(descr);
 immediate = descr->data.value;
 k_pop(1);

 /* Get user number */

 descr = e_stack - 1;
 GetInt(descr);
 user = descr->data.value;

 if (user == 0)
  {
   k_exit_cause = (immediate)?K_LOGOUT:K_TERMINATE;
   status = 1;
  }
 else
  {
   status = raise_event((immediate)?EVT_LOGOUT:EVT_TERMINATE, user);
  }

 descr->data.value = status;
 return;
}

/* ======================================================================
   op_events()  -  EVENTS()                                               */

void op_events()
{
 /* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top |  Event flag values, 0 = query  | Event flag values           |
     |  -ve = unset event             |                             |
     |--------------------------------|-----------------------------|
     |  User number (-ve = all)       |                             |
     |================================|=============================|

 Negative user number is not meaningful for query.
 STATUS() = 0 if user found, non-zero if user not found
 */

 DESCRIPTOR * descr;
 int user;
 long int flags;
 USER_ENTRY * uptr;
 short int i;

 process.status = 1;

 /* Get flag values */

 descr = e_stack - 1;
 GetInt(descr);
 flags = descr->data.value;

 /* Get user number */

 descr = e_stack - 2;
 GetInt(descr);
 user = descr->data.value;
 k_pop(1);

 StartExclusive(SHORT_CODE, 46);
 for(i = 1; i <= sysseg->max_users; i++)
  {
   uptr = UPtr(i);
   if ((uptr->uid == user) || (user < 0))
    {
     if (flags > 0) uptr->events |= flags;
     else if (flags < 0) uptr->events &= ~ -flags;
     descr->data.value = uptr->events;
     process.status = 0;
     if (user > 0) break;
    }
  }
 EndExclusive(SHORT_CODE);
}

/* ======================================================================
   op_setflags()  -  SETFLAGS opcode  - Set opcode_flags                  */

void op_setflags()
{
 register unsigned short int flags;

 flags = *(pc++);
 flags |= *(pc++) << 8;
 
 process.op_flags |= flags;
}

/* ======================================================================
   op_userno()  -  USERNO  -  Get user number (process id + 1)            */

void op_userno()
{
 /* Stack:

     |================================|=============================|
     |            BEFORE              |           AFTER             |
     |================================|=============================|
 top |                                |  User no                    |
     |================================|=============================|
 */

 InitDescr(e_stack, INTEGER);
 (e_stack++)->data.value = process.user_no;
}

/* ======================================================================
   op_unload  -  Unload all inactive object code                          */

void op_unload()
{
 unload_all();
}



/* ======================================================================
   Fatal signal handler                                                   */

void fatal_signal_handler(int signum)
{
 log_printf("Fault type %d. PC = %08lX (%02X %02X) in %s\n",
            signum,
            op_pc - c_base,
            *op_pc, *(op_pc+1),
            ProgramName(c_base));

 printf("Errno : %08X\n", errno);

 {
  int i; 
  DESCRIPTOR * descr;

  /* Show area around top of e-stack */

  for (i = 4; i >= -4; i--)
   {
    descr = e_stack + i;
    printf("%2d %08lX: %02X %02X %08lX %08lX\n",
           i, (long)descr, descr->type, descr->flags, descr->data.dbg.w1,
           descr->data.dbg.w2);
    if (descr == e_stack_base) break;
   }
 }
 
  signal(signum, SIG_DFL);
  raise(signum);
}

/* ======================================================================
   suspend_updates()  -  Pause while suspend in progress                  */

void suspend_updates()
{
 if (!(process.program.flags & PF_IN_TRIGGER))
  {
   while(sysseg->flags & SSF_SUSPEND) Sleep(1000);
  }
}

/* END-CODE */
